home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / awk.scm next >
Text File  |  1995-10-13  |  18KB  |  506 lines
  1. ;;; An awk loop, after the design of David Albertz and Olin Shivers.
  2. ;;; Copyright (c) 1994 by Olin Shivers.
  3.  
  4. ;;; - Requires RECEIVE from RECEIVING package.
  5. ;;; - Would require DESTRUCTURE from DESTRUCTURING package, but it appears
  6. ;;;   to be broken, so we hack it w/cars and cdrs.
  7. ;;; - Requires STRING-MATCH from SCSH package.
  8.  
  9. ;;; This should be hacked to convert regexp strings into regexp structures
  10. ;;; at the top of the form, and then just refer to the structs in the
  11. ;;; tests.
  12.  
  13. ;;; Examples:
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;;
  16. ;;; ;;; Filter -- pass only lines containing my name.
  17. ;;; (awk (read-line) (line) ()
  18. ;;;   ("Olin" (display line) (newline)))
  19. ;;;
  20. ;;; ;;; Count the number of non-comment lines of code in my Scheme source.
  21. ;;; (awk (read-line) (line) ((nlines 0))
  22. ;;;   ("^[ \t]*;" nlines)        ; A comment line.
  23. ;;;   (else       (+ nlines 1)))    ; Not a comment line.
  24. ;;;
  25. ;;;  ;;; Read numbers, counting the evens and odds.
  26. ;;;  (awk (read) (val) ((evens 0) (odds 0))
  27. ;;;     ((zero? val) (display "zero ") (values evens odds)) ; Tell me about
  28. ;;;     ((> val 0)   (display "pos ")  (values evens odds)) ; sign, too.
  29. ;;;     (else        (display "neg ")  (values evens odds))
  30. ;;;
  31. ;;;     ((even? val) (values (+ evens 1) odds))
  32. ;;;     (else        (values evens       (+ odds 1))))
  33.  
  34. ;;; Syntax:
  35. ;;; (awk <reader-exp> <rec&field-vars> [<rec-counter>] <state-var-inits>
  36. ;;;   <clause1> 
  37. ;;;       .
  38. ;;;       .
  39. ;;;   <clausen>)
  40.  
  41. ;;; This macro is written using Clinger/Rees explicit-renaming low-level 
  42. ;;; macros. So it is pretty ugly. It takes a little care to generate 
  43. ;;; cosmetically attractive code, for two reasons:
  44. ;;; - It makes it easier for humans to examine the expanded code.
  45. ;;; - It helps low-tech compilers compile the code well. Some of the
  46. ;;;   optimisations the expander implements would be hard for even a
  47. ;;;   sophisticated compiler to perform automatically. For example, it doesn't
  48. ;;;   introduce a record-counter variable unless required to do so. It's a
  49. ;;;   non-trivial analysis to spot and remove an unused loop variable (I show
  50. ;;;   how to do so in my dissertation; I don't know of any production
  51. ;;;   compilers that do it). Same remarks apply to the variable that tracks
  52. ;;;   the state bit for ELSE clauses -- we don't introduce one unless the loop
  53. ;;;   actually contains ELSE clauses. The lesson here is that loop macros 
  54. ;;;   by definition have information about the data-flow of their bodies that 
  55. ;;;   compilers have to work hard to spot by analysis of their expanded forms.
  56. ;;;   The macro can exploit this knowledge at the high-level.
  57. ;;;
  58. ;;; Interesting research issue: Could one design a macro system that would
  59. ;;; allow the macro to communicate this knowledge to the compiler? Could
  60. ;;; the macro's assertions be verified by the compiler, as well?
  61. ;;;
  62. ;;; In any even, there's a down-side to this cosmetic clean-up:
  63. ;;; all of this optimisation definitely makes the macro a lot more hairy
  64. ;;; than it would otherwise be. The expanded code is easier to read; the
  65. ;;; macro itself is harder to read.
  66.  
  67.  
  68. ;;; Simple syntax-hacking utilities.
  69. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70.  
  71. ;;; Return a form that produces multiple values.
  72. ;;; ()          => (values)
  73. ;;; (v)         => v
  74. ;;; (v1 v2 ...) => (values v1 v2 ...)
  75.  
  76. (define (mult-values vals rename)
  77.   (if (or (not (pair? vals)) (pair? (cdr vals)))
  78.       `(,(rename 'values) . ,vals)
  79.       (car vals)))
  80.  
  81. ;;; ()      => ()
  82. ;;; (v1)    => (v1)
  83. ;;; (v1 v2) => ((VALUES v1 v2))
  84. ;;;
  85. ;;; Return an expression list, not an expression. (Either 1 or 0 expressions.)
  86. ;;; Use this one when we don't care what happens if we are returning 0 vals.
  87. ;;; It pairs up with MV-LET below, which ignores the number of values
  88. ;;; returned to it when expecting zero values.
  89.  
  90. (define (sloppy-mult-values vals rename)
  91.   (if (and (pair? vals) (pair? (cdr vals)))
  92.       `((,(rename 'values) . ,vals))
  93.       vals))
  94.  
  95. ;; DEBLOCK maps an expression to a list of expressions, flattening BEGINS.
  96. ;; (deblock '(begin (begin 3 4) 5 6 (begin 7 8))) => (3 4 5 6 7 8)
  97.  
  98. (define (deblock exp rename compare)
  99.   (let ((%block (rename 'begin)))
  100.     (let deblock1 ((exp exp))
  101.       (if (and (pair? exp)
  102. ;           (name? (car exp))
  103.            (compare %block (car exp)))
  104.       (apply append (map deblock1 (cdr exp)))
  105.       (list exp)))))
  106.  
  107. ;; BLOCKIFY maps an expression list to a BEGIN form, flattening nested BEGINS.
  108. ;; (blockify '( (begin 3 4) 5 (begin 6) )) => (begin 3 4 5 6)
  109.  
  110. (define (blockify exps rename compare)
  111.   (let ((new-exps (apply append
  112.              (map (lambda (exp) (deblock exp rename compare))
  113.                   exps))))
  114.     (cond ((null? new-exps)
  115.        (error "Empty BEGIN" exps))
  116.       ((null? (cdr new-exps))    ; (begin exp) => exp
  117.        (car new-exps))
  118.       (else `(,(rename 'begin) . ,new-exps)))))
  119.  
  120.  
  121. (define (mv-let r c vars exp body)
  122.   (if (pair? vars)
  123.       (if (pair? (cdr vars))
  124.       `(,(r 'receive) ,vars ,exp . ,(deblock body r c))
  125.       `(,(r 'let) ((,(car vars) ,exp)) . ,(deblock body r c)))
  126.       (blockify (list exp body) r c)))
  127.  
  128.  
  129. ;;; Is X one of the keywords {range, :range, range:, :range:}?
  130. (define (range-keyword? x rename compare)
  131.   (or (compare x (rename 'range))
  132.       (compare x (rename ':range))
  133.       (compare x (rename 'range:))
  134.       (compare x (rename ':range:))))
  135.  
  136. ;;; Apply PRED to every element of VALS. Collect & return all the non-#f
  137. ;;; values produced.
  138. (define (all-trues pred vals)
  139.   (let lp ((vals vals) (ans '()))
  140.     (if (pair? vals)
  141.     (lp (cdr vals)
  142.         (cond ((pred (car vals)) => (lambda (elt) (cons elt ans)))
  143.           (else ans)))
  144.     (reverse ans))))
  145.  
  146. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  147.  
  148. (define (expand-awk exp r c)
  149.   (let* ((%lambda      (r 'lambda))    ; Bind a mess of keywords.
  150.      (%let            (r 'let))
  151.      (%receive     (r 'receive))
  152.      (%values      (r 'values))
  153.      (%if        (r 'if))
  154.      (%eof-object?    (r 'eof-object?))
  155.      (%after    (r 'after))
  156.      (%else        (r 'else))
  157.      (%+        (r '+))
  158.  
  159.      (gensym (let ((i 0))
  160.            (lambda (s)
  161.              (set! i (+ i 1))
  162.              (string->symbol (string-append s (number->string i))))))
  163.  
  164.      ;; Is the clause a range-test clause?
  165.      (range? (lambda (clause) (range-keyword? (car clause) r c)))
  166.  
  167.      ;; Make some standard vars we'll need.
  168.      (lp-var (r 'lp))
  169.      (reader (r 'read-rec))
  170.      ;; If I throw in an abort-loop or abort-iteration macro,
  171.      ;; I'll also need to make two vars for the continuations.
  172.  
  173.      ;; Rip the form apart.
  174.      (reader-exp (cadr exp))
  175.      (rec/field-vars (caddr exp))
  176.      (rec-var (car rec/field-vars))    ; The var bound to the record.
  177.      (rest (cdddr exp)))        ; Stuff after the rec&field-vars.
  178.       
  179.     (receive (rec-counter state-inits clauses)        ; Parse out the last
  180.          (if (list? (car rest))            ; three parts of the
  181.          (values #f (car rest) (cdr rest))     ; form.
  182.          (values (car rest) (cadr rest) (cddr rest)))
  183.  
  184.       ;; Some analysis: what have we got?
  185.       ;; Range clauses, else clauses, line num tests,...
  186.       (let* ((recnum-tests?        ; Do any of the clauses test the record
  187.           (any? (lambda (clause)    ; count? (I.e., any integer tests?)
  188.               (let ((test (car clause)))
  189.             (or (integer? test)
  190.                 (and (range? clause)
  191.                  (or (integer? (cadr clause))
  192.                      (integer? (caddr clause)))))))
  193.             clauses))
  194.  
  195.          ;; If any ELSE clauses, bind this to the var in which we
  196.          ;; will keep the else state, otherwise #f.
  197.          (else-var (and (any? (lambda (clause)
  198.                     (c (car clause) %else))
  199.                   clauses)
  200.                 (r 'elss)))
  201.  
  202.          ;; Make a list of state vars for the range clauses.
  203.          ;; For each range clause, we need a boolean var to track
  204.          ;; whether or not the range is activated.
  205.          (range-vars (all-trues (lambda (clause)
  206.                       (and (range? clause)
  207.                        (r (gensym "r."))))
  208.                     clauses))
  209.            
  210.          (svars (map car state-inits))    ; The user's state variables.
  211.          
  212.          ;; If the user didn't declare a record-counter var,
  213.          ;; but he is testing line numbers (with integer test forms),
  214.          ;; go ahead and generate a record-counter of our own.
  215.          (rec-counter (or rec-counter
  216.                   (and recnum-tests?
  217.                    (r (gensym "record-count.")))))
  218.  
  219.          ;; Generate the loop vars & their inits.
  220.          ;; These are: the record counter, the range vars, 
  221.          ;; and the user's state vars. 
  222.          ;; All of these different sets are optional.
  223.          (loop-vars (append (if rec-counter (list rec-counter) '())
  224.                 range-vars
  225.                 svars))
  226.          (loop-var-init-values (append (if rec-counter '(0)  '())
  227.                        (map (lambda (x) #f) range-vars)
  228.                        (map cadr state-inits)))
  229.          ;; A LET list initialising all the loop vars.
  230.          (loop-var-init (map list loop-vars loop-var-init-values))
  231.          
  232.          ;; Build the clause that computes the loop's return value.
  233.          ;; If the user gave an AFTER clause, use its body. Otherwise,
  234.          ;; it's (values ,@svars).
  235.          (after-clause? (lambda (clause) (c (car clause) %after)))
  236.          (after-exp (let ((after-clauses (filter after-clause? clauses)))
  237.               (cond ((null? after-clauses)
  238.                  (mult-values svars r))
  239.                 ((null? (cdr after-clauses))
  240.                  (blockify (cdar after-clauses) r c))
  241.                 (else (error "Multiple AFTER clauses in awk body."
  242.                          after-clauses exp)))))
  243.  
  244.  
  245.          (loop-body (awk-loop-body lp-var rec-var else-var
  246.                        rec-counter range-vars svars
  247.                        clauses r c))
  248.  
  249.          ;; Variables that have to be updated per-iteration, as a LET list.
  250.          ;; Note that we are careful not to increment the record counter
  251.          ;; until after we've verified the new record isn't EOF.
  252.          (per-iteration-updates
  253.               (append (if else-var `((,else-var #t)) '())    ; Else state.
  254.               (if rec-counter            ; Record count.
  255.                   `((,rec-counter (,%+ ,rec-counter 1)))
  256.                   '())))
  257.  
  258.          (loop-body (if (pair? per-iteration-updates)
  259.                 `(,%let ,per-iteration-updates
  260.                    . ,(deblock loop-body r c))
  261.                 loop-body)))
  262.            
  263.     `(,%let ((,reader (,%lambda () ,reader-exp)))
  264.        (,%let ,lp-var ,loop-var-init
  265.          ,(mv-let r c rec/field-vars `(,reader)
  266.             `(,%if (,%eof-object? ,rec-var) ,after-exp
  267.                ,loop-body))))))))
  268.  
  269.  
  270. ;;; Expand into the body of the awk loop -- the code that tests & executes
  271. ;;; each clause, and then jumps to the top of the loop.
  272.  
  273. (define (awk-loop-body lp-var rec-var else-var rec-counter 
  274.                range-vars svars clauses r c)
  275.   (let ((clause-vars (if else-var (cons else-var svars) svars))
  276.     (loop-vars (append (if rec-counter (list rec-counter) '())
  277.                range-vars
  278.                svars))
  279.     (range-clause? (lambda (clause) (range-keyword? (car clause) r c)))
  280.  
  281.     (%after (r 'after))
  282.     (%else  (r 'else)))
  283.  
  284.     (let expand ((clauses clauses) (range-vars range-vars))
  285.       (if (pair? clauses)
  286.       (let* ((clause (car clauses))
  287.          (test   (car clause)))
  288.         (cond ((range-keyword? test r c)
  289.            (let ((tail (expand (cdr clauses) (cdr range-vars))))
  290.              (expand-range-clause clause tail (car range-vars)
  291.                       rec-var else-var rec-counter svars
  292.                       r c)))
  293.  
  294.           ((c test %after)    ; An AFTER clause. Skip it.
  295.            (expand (cdr clauses) range-vars))
  296.  
  297.           ((c test %else)    ; An ELSE clause.
  298.            (let ((tail (expand (cdr clauses) range-vars)))
  299.              (expand-else-clause clause tail else-var svars r c)))
  300.  
  301.           (else            ; A simple clause.
  302.            (let ((tail (expand (cdr clauses) range-vars)))
  303.              (expand-simple-clause clause tail
  304.                        rec-var else-var rec-counter svars
  305.                        r c)))))
  306.  
  307.       ;; No clauses -- just jump to top of loop.
  308.       `(,lp-var . ,loop-vars)))))
  309.  
  310.  
  311. ;;; Make a Scheme expression out of a test form.
  312. ;;; Integer i        =>  (= i <record-counter>)
  313. ;;; String  s        =>  (string-match s <record>)
  314. ;;; Expression e    =>  e
  315.  
  316. (define (->simple-clause-test test-form rec-var rec-counter r)
  317.   (cond ((integer? test-form) `(,(r '=) ,rec-counter ,test-form))
  318.     ((string?  test-form) `(,(r 'string-match) ,test-form ,rec-var))
  319.     (else                 test-form)))
  320.  
  321.  
  322. (define (expand-simple-clause clause tail
  323.                   rec-var else-var rec-counter svars
  324.                   r c)
  325.   (let* ((%let          (r 'let))
  326.      (%=            (r '=))
  327.      (%string-match (r 'string-match))
  328.      (%arrow        (r '=>))
  329.      (%if           (r 'if))
  330.  
  331.          (test (car clause))
  332.      (test (->simple-clause-test test rec-var rec-counter r))
  333.  
  334.      ;; Is clause of the form (test => proc)
  335.      (arrow? (and (= 3 (length clause))
  336.               (c (cadr clause) %arrow)))
  337.  
  338.      (null-clause-list (null-clause-action else-var svars r))
  339.  
  340.      ;; The core form conditionally executes the body.
  341.      ;; It returns the new else var and the new state vars, if any.
  342.      (core (if arrow?
  343.            (let* ((tv (r 'tval))        ; APP is the actual 
  344.               (app `(,(caddr clause) ,tv)))    ; body: (proc tv).
  345.              `(,%let ((,tv ,test))
  346.                 (,%if ,tv
  347.                   ,(clause-action (list app) else-var svars r c)
  348.                   . ,null-clause-list)))
  349.  
  350.            `(,%if ,test ,(clause-action (cdr clause) else-var svars r c)
  351.               . ,null-clause-list)))
  352.  
  353.      (loop-vars (if else-var (cons else-var svars) svars)))
  354.     
  355.     ;; Do the core computation, update the iteration vars,
  356.     ;; and then do the tail in the scope of the updated environment.
  357.     (core-then-tail loop-vars core tail r c)))
  358.  
  359. (define (core-then-tail loop-vars core tail r c)
  360.   (mv-let r c loop-vars core tail))
  361.  
  362. (define (expand-range-clause clause tail range-var
  363.                  rec-var else-var rec-counter svars 
  364.                  r c)
  365.   (let* ((start-test (cadr clause))
  366.      (stop-test (caddr clause))
  367.      (body (cdddr clause))
  368.  
  369.      (%receive (r 'receive))
  370.      (%if      (r 'if))
  371.      (%lambda  (r 'lambda))
  372.  
  373.      (keyword (car clause))    ; range or :range or range: or :range:
  374.      (tester (r (cond ((c keyword (r 'range))   'next-range)
  375.               ((c keyword (r ':range))  'next-:range)
  376.               ((c keyword (r 'range:))  'next-range:)
  377.               ((c keyword (r ':range:)) 'next-:range:)
  378.               (else (error "Unrecognised range keyword!" clause)))))
  379.  
  380.      ;; Convert the start and stop test forms to code.
  381.      (start-test (->simple-clause-test start-test rec-var rec-counter r))
  382.      (stop-test  (->simple-clause-test stop-test  rec-var rec-counter r))
  383.  
  384.      (start-thunk `(,%lambda () ,start-test))    ; ...and thunkate them.
  385.      (stop-thunk  `(,%lambda () ,stop-test))
  386.  
  387.      (loop-vars (if else-var (cons else-var svars) svars))
  388.      (this-rec (r 'this-record?))
  389.  
  390.      (core `(,%if ,this-rec
  391.               ,(clause-action body else-var svars r c)
  392.               . ,(null-clause-action else-var svars r))))
  393.  
  394.     `(,%receive (,this-rec ,range-var)
  395.         (,tester ,start-thunk ,stop-thunk ,range-var)
  396.        ,(core-then-tail loop-vars core tail r c))))
  397.  
  398.  
  399. (define (expand-else-clause clause tail else-var svars r c)
  400.   (let* ((body (cdr clause))
  401.      (tail-exps (deblock tail r c))
  402.  
  403.      (%if      (r 'if))
  404.      (%receive (r 'receive))
  405.      (%let     (r 'let))
  406.      
  407.      ;; We are hard-wiring the else var to #t after this, so the core
  408.      ;; expression doesn't need to return it -- just the new values
  409.      ;; of the user's state vars.
  410.      (core `(,%if ,else-var
  411.               ,(clause-action body #f svars r c)
  412.               . ,(sloppy-mult-values svars r))))
  413.  
  414.     (mv-let r c svars core `(,%let ((,else-var #t)) . ,tail-exps))))
  415.  
  416.  
  417. ;;; BODY is a list of expressions from a loop clause. We want to evaluate it, 
  418. ;;; under some conditions.
  419. ;;; - The body evaluates to multiple values, one for each state variable.
  420. ;;;   However, if there are no state variables, we want to *ignore* the
  421. ;;;   values produced by the body, and explicitly return 0 values,
  422. ;;;   not blow up if the body should happen not to return exactly zero values.
  423. ;;; - If we are tracking an else-variable, then the body firing will turn
  424. ;;;   it off by returning its new #f value.
  425.  
  426. (define (clause-action body else-var svars r c)
  427.   (let ((%values  (r 'values))
  428.     (%receive (r 'receive)))
  429.  
  430.     (blockify (if (pair? svars)
  431.  
  432.           (if else-var
  433.               (if (cdr svars)    ; We've got state vars and an else var.
  434.               `((,%receive ,svars ,(blockify body r c)
  435.                   (,%values #f . ,svars)))
  436.               `((,%values #f ,(blockify body r c)))) ; Gratuitous.
  437.               body)            ; State vars, but no else var.
  438.            
  439.           ;; No state vars -- ignore value computed by BODY forms.
  440.           `(,@body . ,(if else-var '(#f) `())))
  441.           r c)))
  442.       
  443.  
  444. ;;; The clause didn't execute. Return the svars unchanged, and also
  445. ;;; return the current else-value if we are tracking one. We return
  446. ;;; a 0 or 1 element expression list -- if no values are being expected
  447. ;;; this returns the empty list.
  448.  
  449. (define (null-clause-action else-var svars r)
  450.   (sloppy-mult-values (if else-var (cons else-var svars) svars)
  451.               r))
  452.       
  453.  
  454.  
  455. ;;; These procs are for handling RANGE clauses.
  456. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  457. ;;; First return value tells whether this line is active;
  458. ;;; next value tells whether region is active after this line.
  459. ;;;
  460. ;;; (:range  0 4) = 0 1 2 3    This is the most useful one.
  461. ;;; (range:  0 4) = 1 2 3 4
  462. ;;; (range   0 4) = 1 2 3
  463. ;;; (:range: 0 4) = 0 1 2 3 4
  464.  
  465. ;;; If these were inlined and the test thunks substituted, it would
  466. ;;; be acceptably efficient. But who writes Scheme compilers that good
  467. ;;; in the 90's?
  468.  
  469. (define (next-:range start-test stop-test state)
  470.   (let ((new-state (if state
  471.                (or (not (stop-test))         ; Stop,
  472.                (start-test))        ;   but restart.
  473.  
  474.                (and (start-test)        ; Start,
  475.                 (not (stop-test))))))    ;   but stop, too.
  476.     (values new-state new-state)))
  477.  
  478. (define (next-range: start-test stop-test state)
  479.   (values state
  480.       (if state
  481.           (or (not (stop-test))        ; Stop,
  482.           (start-test))            ;   but restart.
  483.           (and (start-test)            ; Start,
  484.            (not (stop-test))))))    ;   but stop, too.
  485.  
  486. (define (next-range start-test stop-test state)
  487.   (if state
  488.       (let ((not-stop (not (stop-test))))
  489.     (values not-stop                
  490.         (or not-stop            ; Stop,
  491.             (start-test))))        ;   but restart.
  492.       (values #f
  493.           (and (start-test)            ; Start,
  494.            (not (stop-test))))))     ;   but stop, too.
  495.  
  496. (define (next-:range: start-test stop-test state)
  497.   (if state
  498.       (values #t
  499.           (or (not (stop-test))        ; Stop
  500.           (start-test)))        ;   but restart.
  501.  
  502.       (let ((start? (start-test)))
  503.     (values start?
  504.         (and start?            ; Start,
  505.              (not (stop-test)))))))    ;   but stop, too.
  506.